home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr48
/
pasclern.zip
/
OT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-04-01
|
26KB
|
704 lines
PROGRAM Oak_tree;
(* XXX X X X XXXXX XXXX XXXXX XXXXX
July 14, 1986 X X X X X X X X X X X
X X X X X X X X X X X
X X X X XX X XXXX XXX XXX
X X XXXXX X X X X X X X
X X X X X X X X X X X
XXX X X X X X X X XXXXX XXXXX
*)
CONST page_size = 66;
max_lines = 55;
TYPE command_string = STRING[127];
output_type = (directories,files);
REGPACK = RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS:INTEGER;
END;
dir_rec = ^DIRTREE; (* Dynamic storage for dir names *)
DIRTREE = RECORD
next : dir_rec;
dir_name : STRING[15];
END;
filerec = ^FILETREE; (* Dynamic storage for the *)
FILETREE = RECORD (* filename sorting tree *)
left : filerec;
right : filerec;
CASE BOOLEAN OF
TRUE : (attribute : BYTE;
file_time : ARRAY[1..2] OF BYTE;
file_date : ARRAY[1..2] OF BYTE;
file_size : ARRAY[1..4] OF BYTE;
file_name : ARRAY[1..13] OF CHAR);
FALSE : (file_rec : ARRAY[1..23] OF CHAR);
END;
VAR file_point : filerec; (* Pointer to a file record *)
page_number : INTEGER;
line_number : INTEGER;
directory_count : INTEGER;
recpack : REGPACK;
dta : ARRAY[1..43] OF CHAR; (* Disk xfer address *)
file_request : STRING[25];
root_mask : command_string; (* Used for vol-label search *)
starting_path : command_string;
cluster_size : INTEGER;
sectors_per_cluster : INTEGER;
free_clusters : INTEGER;
bytes_per_sector : INTEGER;
total_clusters : INTEGER;
do_we_print : BOOLEAN; (* Print or not *)
do_all_stats : BOOLEAN; (* List all disk stats? *)
no_files_out : BOOLEAN; (* List no files *)
which_list : output_type;
real_size : REAL;
r1,r2,r3 : REAL;
total_cbytes : REAL;
total_bytes : REAL;
all_files : INTEGER;
req_files : INTEGER;
(* ***************************************************** Initialize *)
(* This procedure is used to initialize some variables and strings *)
(* prior to starting the disk search. *)
PROCEDURE initialize;
BEGIN
page_number := 1;
line_number := 1;
directory_count := 0;
total_cbytes := 0;
total_bytes := 0;
all_files := 0;
req_files := 0;
root_mask := 'C:\*.*';
root_mask[length(root_mask) + 1] := chr(0);
(* Get the current default drive letter *)
recpack.AX := $1900;
intr($21,recpack);
root_mask[1] := chr(recpack.AX AND $F + ord('A'));
END;
(* ******************************* Read And Parse Command Arguments *)
(* This procedure reads in the command line arguments, parses them, *)
(* and sets up the switches and defaults for the disk searches. *)
PROCEDURE read_and_parse_command_arguments;
VAR parameters_input : command_string ABSOLUTE CSEG:$80;
parameters : command_string;
index : BYTE;
temp_store : CHAR;
BEGIN
do_we_print := FALSE;
do_all_stats := FALSE;
no_files_out := FALSE;
(* First, preserve the input area to allow F3 to repeat *)
FOR index := 0 TO length(parameters_input) DO
parameters[index] := parameters_input[index];
FOR index := 1 TO length(parameters) DO
BEGIN
(* Find designated drive letter *)
IF ((parameters[index] = ':') AND (index > 1)) THEN
BEGIN
root_mask[1] := parameters[index-1];
parameters[index-1] := ' ';
parameters[index] := ' ';
END;
(* Find command line switches *)
IF (parameters[index] = '/') AND (index < length(parameters))
THEN
BEGIN
temp_store := upcase(parameters[index + 1]);
IF temp_store = 'P' THEN do_we_print := TRUE;
IF temp_store = 'N' THEN no_files_out := TRUE;
IF temp_store = 'S' THEN do_all_stats := TRUE;
parameters[index] := ' ';
parameters[index+1] := ' ';
END;
END;
(* get the current path on the selected drive *)
getdir(ord(root_mask[1])-ord('A') + 1,starting_path);
IF length(starting_path) > 3 THEN
starting_path := starting_path + '\';
(* Finally, find the file name mask for searching *)
REPEAT (* Remove leading blanks *)
IF parameters[1] = ' ' THEN delete(parameters,1,1);
UNTIL (parameters[1] <> ' ') OR (length(parameters) = 0);
index := 0; (* Remove everything trailing the first entry *)
REPEAT
index := index + 1;
UNTIL (parameters[index] = ' ') OR (index=length(parameters) + 1);
delete(parameters,index,127);
IF parameters = '' THEN
file_request := '*.*'
ELSE
file_request := parameters;
END;
(* ********************************************* count print lines *)
PROCEDURE count_print_lines(line_count : BYTE);
VAR count : BYTE;
BEGIN
IF do_we_print THEN
BEGIN
IF line_count > 250 THEN (* This signals the end of the tree *)
BEGIN (* Space up to a new page *)
FOR count := line_number TO (page_size - 3) DO
WRITELN(lst);
line_number := 1;
line_count := 0;
END;
line_number := line_number + line_count;
IF line_number > max_lines THEN
BEGIN
page_number := page_number +1;
FOR count := line_number TO (page_size - 2) DO
WRITELN(lst);
WRITELN(lst,' Page',page_number:4);
WRITELN(lst);
line_number := 1;
END;
END;
END;
(* *************************************************** Print Header *)
(* In this section of code, the volume label is found and displayed *)
(* and the present time and date are determined and displayed. *)
PROCEDURE print_header;
VAR month,day,hour,minute : STRING[2];
year : STRING[4];
error : INTEGER;
attribute : BYTE;
temp : BYTE;
done : BOOLEAN;
index : INTEGER;
BEGIN
IF do_we_print THEN
BEGIN
WRITELN(lst);
WRITELN(lst);
WRITELN(lst);
WRITE(lst,' Directory for ');
END;
WRITE(' Directory for ');
recpack.AX := $1A00; (* Set up the DTA *)
recpack.DS := seg(dta);
recpack.DX := ofs(dta);
msdos(recpack); (* DTA setup complete *)
error := recpack.AX AND $FF;
IF error > 0 THEN WRITELN('DTA setup error ',error);
recpack.AX := $4E00; (* Get the volume ID *)
recpack.DS := seg(root_mask[1]);
recpack.DX := ofs(root_mask[1]);
recpack.CX := 8;
intr($21,recpack);
error := recpack.AX AND $FF;
attribute := $1F AND mem[seg(dta):ofs(dta) + 21];
IF ((error > 0) OR (attribute <> 8)) THEN
BEGIN
IF do_we_print THEN
WRITE(lst,' <no vol label> ');
WRITE(' <no vol label> ');
END
ELSE
BEGIN (* Write out Volume Label *)
done := FALSE;
FOR index := 30 TO 40 DO
BEGIN
temp := mem[seg(dta):ofs(dta) + index];
IF temp = 0 THEN done := TRUE;
IF done = FALSE THEN
BEGIN
IF do_we_print THEN
WRITE(lst,chr(temp));
WRITE(chr(temp));
END;
END;
END;
WRITE(' ');
IF do_we_print THEN
WRITE(lst,' ');
recpack.AX := $2A00; (* Get the present date *)
msdos(recpack);
str(recpack.CX:4,Year);
str((recpack.DX MOD 256):2,day);
str((recpack.DX SHR 8):2,month);
IF day[1] = ' ' THEN day[1] := '0';
WRITE(month,'/',day,'/',year);
IF do_we_print THEN
WRITE(lst,month,'/',day,'/',year);
recpack.AX := $2C00; (* Get the present time *)
msdos(recpack);
str((recpack.CX SHR 8):2,hour);
str((recpack.CX MOD 256):2,minute);
IF minute[1] = ' ' THEN minute[1] := '0';
WRITELN(' ',hour,':',minute);
WRITELN;
IF do_we_print THEN
BEGIN
WRITELN(lst,' ',hour,':',minute);
WRITELN(lst);
count_print_lines(2);
END;
(* get all of the disk constants *)
recpack.AX := $3600;
recpack.DX := (ord(root_mask[1]) - 64) AND $F;
msdos(recpack);
sectors_per_cluster := recpack.AX;
free_clusters := recpack.BX;
bytes_per_sector := recpack.CX;
total_clusters := recpack.DX;
cluster_size := bytes_per_sector * sectors_per_cluster;
IF do_all_stats THEN (* Print out disk statistics if asked for *)
BEGIN
WRITE(' bytes/sector =',bytes_per_sector:6);
r1 := total_clusters;
r2 := cluster_size;
r1 := r1 *r2;
WRITELN(' total disk space =',r1:12:0);
WRITE(' bytes/cluster =',cluster_size:6);
r3 := free_clusters;
r2 := r3 * r2;
WRITELN(' free disk space =',r2:12:0);
WRITELN;
IF do_we_print THEN
BEGIN
WRITE(lst,' bytes/sector =',bytes_per_sector:6);
WRITELN(lst,' total disk space =',r1:12:0);
WRITE(lst,' bytes/cluster =',cluster_size:6);
WRITELN(lst,' free disk space =',r2:12:0);
WRITELN(lst);
count_print_lines(3);
END;
END;
END;
(* *************************************** Position a new filename *)
(* When a new filename is found, this routine is used to locate it *)
(* in the B-TREE that will be used to sort the filenames alphabet- *)
(* ically. *)
PROCEDURE position_a_new_filename(root, new : filerec);
VAR index : INTEGER;
done : BOOLEAN;
BEGIN
index := 1;
done := FALSE;
REPEAT
IF new^.file_name[index] < root^.file_name[index] THEN
BEGIN
done := TRUE;
IF root^.left = nil THEN root^.left := new
ELSE
position_a_new_filename(root^.left,new);
END
ELSE IF new^.file_name[index] > root^.file_name[index] THEN
BEGIN
done := TRUE;
IF root^.right = nil THEN root^.right := new
ELSE
position_a_new_filename(root^.right,new);
END;
index := index +1;
UNTIL (index = 13) OR done;
END;
(* *************************************************** Print a file *)
(* This is used to print the data for one complete file. It is *)
(* called with a pointer to the root and an attribute that is to be *)
(* printed. Either the directories are printed (attribute = $10), *)
(* or the files are printed. *)
PROCEDURE print_a_file(root : filerec;
which_list : output_type);
VAR index,temp : BYTE;
temp_string : STRING[25];
day : STRING[2];
BEGIN
temp := root^.attribute;
IF ((temp = $10) AND (which_list = directories)) OR
((temp <> $10) AND (which_list = files)) THEN
BEGIN
WRITE(' ');
CASE temp OF
$27 : WRITE('<HID> ');
$10 : WRITE('<DIR> ');
$20 : WRITE(' ')
ELSE WRITE('<',temp:3,'> ');
END; (* of CASE *)
IF do_we_print THEN
BEGIN
WRITE(lst,' ');
CASE temp OF
$27 : WRITE(lst,'<HID> ');
$10 : WRITE(lst,'<DIR> ');
$20 : WRITE(lst,' ')
ELSE WRITE(lst,'<',temp:3,'> ');
END; (* of CASE *)
END;
temp_string := ' ';
index := 1;
REPEAT
temp := ord(root^.file_name[index]);
IF temp > 0 THEN
temp_string[index] := root^.file_name[index];
index := index + 1;
UNTIL (temp = 0) OR ( index = 14);
temp_string[0] := chr(15);
WRITE(temp_string);
IF do_we_print THEN
WRITE(lst,temp_string);
(* Write out the file size *)
r1 := root^.file_size[1];
r2 := root^.file_size[2];
r3 := root^.file_size[3];
real_size := r3*65536.0 + r2 * 256.0 + r1;
WRITE(real_size:9:0);
IF do_we_print THEN
WRITE(lst,real_size:9:0);
(* Write out the file date *)
temp := ((root^.file_date[1] SHR 5) AND $7);
WRITE(' ',(temp + ((root^.file_date[2] AND 1) SHL 3)):2,'/');
IF do_we_print THEN
WRITE(lst,' ',
(temp+((root^.file_date[2] AND 1) SHL 3)):2,'/');
str((root^.file_date[1] AND $1F):2,day);
IF day[1] = ' ' THEN day[1] := '0';
WRITE(day,'/');
WRITE(80 + ((root^.file_date[2] SHR 1) AND $7F),' ');
IF do_we_print THEN
BEGIN
WRITE(lst,day,'/');
WRITE(lst,80 + ((root^.file_date[2] SHR 1) AND $7F),' ');
END;
(* Write out the file time *)
WRITE(' ',((root^.file_time[2] SHR 3) AND $1F):2,':');
IF do_we_print THEN
WRITE(lst,' ',((root^.file_time[2] SHR 3) AND $1F):2,':');
temp := ((root^.file_time[2]) AND $7) SHL 3;
str((temp + ((root^.file_time[1] SHR 5) AND $7)):2,day);
IF day[1] = ' ' THEN day[1] := '0';
WRITELN(day);
IF do_we_print THEN
BEGIN
WRITELN(lst,day);
count_print_lines(1);
END;
END;
END;
(* ********************************************** Print a directory *)
(* This is a recursive routine to print out the filenames in alpha- *)
(* betical order. It uses a B-TREE with "infix" notation. The *)
(* actual printing logic was removed to another procedure so that *)
(* the recursive part of the routine would not be too large and *)
(* up the heap too fast. *)
PROCEDURE print_a_directory(root : filerec;
which_list : output_type);
BEGIN
IF root^.left <> nil THEN
print_a_directory(root^.left,which_list);
(* Write out the filename *)
print_a_file(root,which_list);
IF root^.right <> nil THEN
print_a_directory(root^.right,which_list);
END;
(* ***************************************************** Erase tree *)
(* After the directory is printed and counted, it must be erased or *)
(* the "heap" may overflow for a large disk with a lot of files. *)
PROCEDURE erase_tree(root : filerec);
BEGIN
IF root^.left <> nil THEN erase_tree(root^.left);
IF root^.right <> nil THEN erase_tree(root^.right);
dispose(root);
END;
(* ************************************************* Do A Directory *)
(* This procedure reads all entries in any directory and sorts the *)
(* filenames alphabetically. Then it prints out the complete stat- *)
(* istics, and calls itself to do all of the same things for each *)
(* of its own subdirectories. Since each subdirectory also calls *)
(* each of its subdirectories, the recursion continues until there *)
(* are no more subdirectories. *)
PROCEDURE do_a_directory(input_mask : command_string);
VAR mask : command_string;
count,index : INTEGER;
error : BYTE;
cluster_count : INTEGER;
byte_count : REAL;
tree_root : filerec; (* Root of file tree *)
dir_root : dir_rec;
dir_point : dir_rec;
dir_last : dir_rec;
(* This embedded procedure is called upon to store all of the *)
(* directory names in a linear linked list rather than a *)
(* B-TREE since it should be rather short and efficiency of *)
(* sorting is not an issue. A bubble sort will be used on it. *)
PROCEDURE store_dir_name;
VAR temp_string : STRING[15];
temp : BYTE;
index : BYTE;
BEGIN
temp := mem[seg(dta):ofs(dta) + 21]; (* Attribute *)
IF temp = $10 THEN (* Pick out directories *)
BEGIN
index := 1;
REPEAT
temp := mem[seg(dta):ofs(dta) + 29 + index];
IF temp > 0 THEN
temp_string[index] := chr(temp);
index := index + 1;
UNTIL (temp = 0) OR (index = 14);
temp_string[0] := chr(index - 2);
(* Directory name found, ignore if it is a '.' *)
IF temp_string[1] <> '.' THEN
BEGIN
new(dir_point);
dir_point^.dir_name := temp_string;
dir_point^.next := nil;
IF dir_root = nil THEN
dir_root := dir_point
ELSE
dir_last^.next := dir_point;
dir_last := dir_point;
END;
END;
END;
(* This is the procedure that sorts the directory names after *)
(* they are all accumulated. It uses a bubble sort technique *)
(* which is probably the most inefficient sort available. It *)
(* is perfectly acceptable for what is expected to be a very *)
(* short list each time it is called. More than 30 or 40 *)
(* subdirectories in one directory would not be good practice *)
(* but this routine would sort any number given to it. *)
PROCEDURE sort_dir_names;
VAR change : BYTE;
save_string : STRING[15];
dir_next : dir_rec;
BEGIN
REPEAT
change := 0;
dir_point := dir_root;
WHILE dir_point^.next <> nil DO
BEGIN
dir_next := dir_point^.next;
save_string := dir_next^.dir_name;
IF save_string < dir_point^.dir_name THEN
BEGIN
dir_next^.dir_name := dir_point^.dir_name;
dir_point^.dir_name := save_string;
change := 1;
END;
dir_point := dir_point^.next;
END;
UNTIL change = 0; (* No swaps in this pass, we are done *)
END;
BEGIN
count := 0;
cluster_count := 0;
dir_root := nil;
mask := input_mask + '*.*';
mask[length(mask) + 1] := chr(0); (* A trailing zero for DOS *)
(* Count all files and clusters *)
REPEAT
IF count = 0 THEN
BEGIN (* Get first directory entry *)
recpack.AX := $4E00;
recpack.DS := seg(mask[1]);
recpack.DX := ofs(mask[1]);
recpack.CX := $17; (* Attribute for all files *)
intr($21,recpack);
END
ELSE
BEGIN (* Get additional directory entries *)
recpack.AX := $4F00;
intr($21,recpack);
END;
error := recpack.AX AND $FF;
IF error = 0 THEN (* A good filename is found *)
BEGIN
count := count +1; (* Add one for a good entry *)
(* Count up the number of clusters used *)
r1 := mem[seg(dta):ofs(dta) + 26];
r2 := mem[seg(dta):ofs(dta) + 27];
r3 := mem[seg(dta):ofs(dta) + 28];
real_size := r3*65536.0 + r2 * 256.0 + r1; (*Nmbr of bytes*)
r1 := cluster_size;
r1 := real_size/r1; (* Number of clusters *)
index := trunc(r1);
r2 := index;
IF (r1 - r2) > 0.0 THEN
index := index +1; (* If a fractional part *)
cluster_count := cluster_count + index;
IF index = 0 THEN (* This is a directory, one cluster *)
cluster_count := cluster_count +1;
store_dir_name;
END;
UNTIL error > 0;
r1 := cluster_count;
r2 := cluster_size;
r1 := r1 * r2;
directory_count := directory_count + 1;
WRITE(' ',directory_count:3,'. ');
WRITE(input_mask);
FOR index := 1 TO (32 - length(input_mask)) DO WRITE(' ');
WRITELN(count:4,' Files Cbytes =',r1:9:0);
IF do_we_print THEN
BEGIN
WRITE(lst,' ',directory_count:3,'. ');
WRITE(lst,input_mask);
FOR index := 1 TO (32 - length(input_mask)) DO WRITE(lst,' ');
WRITELN(lst,count:4,' Files Cbytes =',r1:9:0);
count_print_lines(1);
END;
total_cbytes := total_cbytes + r1;
all_files := all_files + count;
(* files counted and clusters counted *)
(* Now read in only the requested files *)
count := 0;
byte_count := 0;
tree_root := nil;
IF no_files_out <> TRUE THEN
BEGIN
mask := input_mask + file_request;
mask[length(mask) + 1] := chr(0); (* A trailing zero for DOS *)
REPEAT
new(file_point);
IF count = 0 THEN
BEGIN (* Get first directory entry *)
recpack.AX := $4E00;
recpack.DS := seg(mask[1]);
recpack.DX := ofs(mask[1]);
recpack.CX := $17; (* Attribute for all files *)
intr($21,recpack);
END
ELSE
BEGIN (* Get additional directory entries *)
recpack.AX := $4F00;
intr($21,recpack);
END;
error := recpack.AX AND $FF;
IF error = 0 THEN (* A good filename is found *)
BEGIN
count := count +1; (* Add one for a good entry *)
file_point^.left := nil;
file_point^.right := nil;
FOR index := 1 TO 23 DO
file_point^.file_rec[index] :=
char(mem[seg(dta):ofs(dta) + 20 + index]);
IF tree_root = nil THEN
BEGIN (* Point to first element in tree *)
tree_root := file_point;
END
ELSE
BEGIN (* Point to additional elements in tree *)
position_a_new_filename(tree_root,file_point);
END;
(* Count up the number of bytes used *)
r1 := file_point^.file_size[1];
r2 := file_point^.file_size[2];
r3 := file_point^.file_size[3];
real_size := r3*65536.0 + r2 * 256.0 + r1; (*Number of *)
(* bytes used. *)
byte_count := byte_count + real_size;
END;
UNTIL error > 0;
END;
which_list := directories;
IF tree_root <> nil THEN
print_a_directory(tree_root,which_list);
IF tree_root <> nil THEN
print_a_directory(tree_root,succ(which_list));
IF count > 0 THEN
BEGIN
WRITELN(' ',count:5,' Files ',
byte_count:17:0,' Bytes');
WRITELN;
IF do_we_print THEN
BEGIN
WRITELN(lst,' ',count:5,' Files ',
byte_count:17:0,' Bytes');
WRITELN(lst);
count_print_lines(2);
END;
total_bytes := total_bytes + byte_count;
req_files := req_files + count;
END;
(* Now go do all of the subdirectories *)
IF dir_root <> nil THEN sort_dir_names;
dir_point := dir_root;
WHILE dir_point <> nil DO
BEGIN
mask := input_mask + dir_point^.dir_name + '\';
do_a_directory(mask);
dir_point := dir_point^.next;
END;
(* Finally, erase the tree and the list *)
IF tree_root <> nil THEN
erase_tree(tree_root);
WHILE dir_root <> nil DO
BEGIN
dir_point := dir_root^.next;
dispose(dir_root);
dir_root := dir_point;
END;
END;
(* ******************************************* Output Summary Data *)
PROCEDURE output_summary_data;
BEGIN
WRITELN;
WRITE(' ',req_files:5,' Files');
WRITELN(total_bytes:15:0,' Bytes in request');
WRITE(' ',all_files:5,' Files');
WRITELN(total_cbytes:15:0,' Cbytes in tree');
WRITE(' ');
r1 := free_clusters;
r2 := cluster_size;
r1 := r1 * r2;
WRITELN(r1:12:0,' Bytes free on disk');
IF do_we_print THEN
BEGIN
WRITELN(lst);
WRITE(lst,' ',req_files:5,' Files');
WRITELN(lst,total_bytes:15:0,' Bytes in request');
WRITE(lst,' ',all_files:5,' Files');
WRITELN(lst,total_cbytes:15:0,' Cbytes in tree');
WRITE(lst,' ');
WRITELN(lst,r1:12:0,' Bytes free on disk');
count_print_lines(4); (* Signal the end, space paper up *)
END;
END;
BEGIN (* Main program - Oak Tree ********************************* *)
initialize;
read_and_parse_command_arguments;
print_header;
do_a_directory(starting_path);
output_summary_data;
count_print_lines(255);
END. (* Main Program *)